home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
BBS Toolkit
/
BBS Toolkit.iso
/
doors_2
/
twview91.zip
/
TOUR.INC
< prev
next >
Wrap
Text File
|
1992-03-11
|
12KB
|
434 lines
type
SectorVisitStatus = (unreachable, visited, scanned, open);
ScannerMap = array [1..MaxSector] of SectorVisitStatus;
route = record
length : sectorIndex; { actual trip length }
more : integer; { how many more to hit }
path : array [ 1..2000 ] of sector;
end;
nodeptr = ^node;
node = record next : nodeptr; s : sector; end;
squeue = record front, rear : nodeptr; end;
procedure ensqueue( e : sector; var q : squeue );
var
NewGuy : nodeptr;
begin
New( NewGuy );
if NewGuy = nil then
begin
writeln('error: out of memory during ensqueue');
readln;
halt;
end;
with NewGuy^ do
begin
s := e;
next := nil;
end; {with}
if q.rear = nil then
q.front := newguy
else
q.rear^.next := newguy;
q.rear := newguy;
end;
procedure sserve( var e : sector; var q : squeue );
var
killer : nodeptr;
begin
if q.front = nil then
begin
writeln('error: serve from empty squeue');
readln;
halt;
end;
killer := q.front;
with killer^ do
begin
e := s;
q.front := next;
end; {with}
if q.front = nil then
q.rear := nil;
dispose( killer );
end;
procedure screate( var q : squeue );
begin
q.front := nil;
q.rear := nil;
end;
procedure Scan( s : sector; var m : scannerMap; var LeftOpen : integer );
{ visit s; mark every sector adjacent to s as examined. }
var
j : warpindex;
begin
m[s] := visited;
with space.sectors[s] do
for j := 1 to number do
if m[ data[j] ] = open then
begin
m[ data[j] ] := scanned;
LeftOpen := LeftOpen - 1;
write('.');
end;
end; {scan}
procedure InitToOpen( var s : ScannerMap );
{ initialize all known or adjacent to known sectors to "open", rest to
unreachable. Warn if there are reachable unexplored sectors. }
var
i : sector;
q : squeue;
j : warpindex;
begin
for i := 1 to MaxSector do
s[i] := unreachable;
screate( q );
ensqueue( 1, q );
while q.front <> nil do
begin
sserve( i, q );
s[i] := open;
with space.sectors[i] do
for j := 1 to number do
if s[ data[j] ] = unreachable then
ensqueue( data[ j ], q );
end; {while}
for i := 1 to MaxSector do
if s[i] = unreachable then
writeln('Sector ', i, ' unreachable.');
end; {Initialize to all open}
procedure SaveMapToDisk( var s : scannermap );
var
f : text;
i : sector;
begin
assign( f, GetNewFileName('File containing sector map? ',BBSName+'.map'));
rewrite( f );
for i := 1 to MaxSector do
case s[i] of
unreachable : writeln( f, i:4, ' unreachable');
visited : writeln( f, i:4, ' visited');
scanned : writeln( f, i:4, ' scanned');
open : ;
end; {for case}
close( f );
end;
procedure EditMap( var s : scannermap );
var
dummy : integer;
i : SectorIndex;
begin
writeln('First, enter those sectors you know about (i.e. from Etherprobes)');
writeln('but where the adjacent sectors were not scanned.');
writeln;
writeln('Enter 0 to finish.');
read( i );
while i <> 0 do
begin
s[i] := scanned;
read( i );
end; {while}
writeln('Now enter those sectors that you have performed scans in. 0 to finish.');
read( i );
while i <> 0 do
begin
Scan( i, s, dummy );
read( i );
end; {while}
readln;
end;
procedure InitMapFromDisk( var s : scannermap );
var
f : text;
i : integer;
SVStatus : string;
begin
for i := 1 to MaxSector do
s[i] := open;
assign( f, GetOldFileName( 'Name map is saved under? ', BBSName+'.map' ));
reset( f );
while not eof( f ) do
begin
i := ReadNumber( f );
readln( f, SVstatus );
if i <> 0 then
case SVStatus[1] of
'u' : s[i] := unreachable;
's' : s[i] := scanned;
'v' : s[i] := visited;
else
writeln('Line "', i, ' ', SVstatus, '" not understood.');
end; {if case}
end; {while}
end;
procedure SetUpToVisit( var s : scannermap );
var
i : sector;
ch: char;
begin
write('Start with <F>resh map, or <R>ead in map from disk? ');
readln( ch );
if upcase( ch ) = 'R' then
InitMapFromDisk( s )
else
InitToOpen( s );
repeat
write('<E>dit map, <S>ave map, or <C>ontinue? ');
readln( ch );
if upcase( ch ) = 'E' then
EditMap( s )
else if upcase( ch ) = 'S' then
SaveMapToDisk( s );
until not (ch in ['e','E','s','S']);
end;
function PathToThing( start : sector;
var map : scannermap;
which : integer ) : sectorindex;
{ Adjusts Distances from start up to point where "which" criteria is found;
returns sector or 0 if no appropriate sector found. }
var
s : sector;
breadth : queue;
daddy, sonny : sector;
i : warpindex;
done : boolean;
begin
for s := 1 to maxSector do
Distances[s].d := -1;
breadth.front := 0;
enqueue( breadth, start, start );
repeat
serve( breadth, daddy, sonny );
if Distances[ sonny ].d = -1 then {haven't hit him before:}
begin
distances[ sonny ].d := distances[ daddy ].d + 1;
distances[ sonny ].s := daddy;
with space.sectors[ sonny ] do if number > 0 then
if (space.sectors[sonny].etc and avoid) = Nothing then
for i := 1 to number do
enqueue( breadth, sonny, data[ i ] );
case which of
1 : done := map[ sonny ] = open;
2 : done := (space.sectors[ sonny ].number = 1) and (map[sonny]=open);
end; {case}
end; {if}
until done or (breadth.front = 0);
if done then
PathToThing := sonny
else
PathToThing := 0;
end; {Path to Open}
function NumberOpen( var m : ScannerMap ) : integer;
{ return the number of open sectors in array }
var
count : integer;
i : sector;
begin
count := 0;
for i := 1 to MaxSector do
if m[i] = open then
count := count + 1;
NumberOpen := count;
end;
procedure AddToRoute( target : sector;
var Travels : route;
var map : scannermap );
{ assumes Distances has already been properly set up. We travel from
current position to target. If target is adjacent to the current location,
great, extend path; otherwise we have to recursively move one step
closer, and add that. }
begin
if not IsWarp( travels.path[ travels.length ], target ) then
AddToRoute( distances[ target ].s, travels, map );
travels.length := travels.length + 1;
travels.path[ travels.length ] := target;
scan( target, map, travels.more );
end;
procedure DoSomethingRandom(var visit : route; { travels so far }
var map : scannerMap); { map visited sectors }
{ Go adjacent to a random open sector }
var
target : sectorindex;
skip : sectorindex;
begin
skip := random( visit.more ) + 1;
target := 0;
repeat
target := target + 1;
while map[ target ] <> open do
target := target + 1;
skip := skip - 1;
until skip = 0;
writeln('random jog to ', target, ' of length ',
FixPath( visit.path[ visit.length ], target ) );
AddToRoute( distances[ target ].s, visit, map );
end; {DoSomethingRandom}
procedure VisitNearestOpen(var visit : route; { travels so far }
var map : scannerMap); { map visited sectors }
begin
AddToRoute( distances[ pathToThing( visit.path[visit.length], map, 1 ) ].s,
visit, map );
end; {VisitNearestOpen}
procedure VisitNearestDeadEnd( var visit : route;
var map : scannerMap );
var
s : sectorIndex;
begin
s := PathToThing( visit.path[ visit.length ], map, 2);
if s = 0 then
begin
writeln('Out of dead ends');
VisitNearestOpen( visit, map );
end
else
AddToRoute( distances[s].s, visit, map );
end;
procedure FindRandomRoute( var Travels : route; map : ScannerMap );
{ Find a route through the galaxy that visits or scans every sector in the
map that isn't marked unreachable. }
var
roll : integer;
greed : integer; { percentage of doing something random }
ToGo : integer; { how many open sectors remain }
begin
write('Starting sector? ');
readln( travels.path[1] );
travels.length := 1;
Scan( travels.path[1], map, travels.more );
travels.more := NumberOpen( map );
write('Random percentage? (0=greedy algorithm, 100=random path) ');
readln( greed );
while travels.more > 0 do
begin
roll := random( 100 );
if roll < greed then
DoSomethingRandom( travels, map )
else if roll < greed * 10 then
VisitNearestDeadEnd( travels, map )
else
VisitNearestOpen( travels, map );
end; {while}
end; {FindRandomRoute}
procedure PrintTour( var t : route );
{print tour to screen, and optionally to disk }
var
f : text;
i : sectorindex;
filename : string;
begin
writeln('path is of length ', t.length );
write('Name of file? Hit return to display to screen: ');
readln( filename );
assign( f, filename );
rewrite( f );
for i := 1 to t.length do
begin
write( f, t.path[i] : 8 );
if i mod 8 = 0 then
writeln(f);
end; {for}
writeln( f );
if filename <> '' then
close( f );
end; {PrintTour}
procedure VisitEverySector;
{ Passed "SPACE" by side effect. Goal is to find a (short) path that will be
adjacent to every observed sector in the galaxy. }
var
KnownGalaxy : scannerMap;
GalacticTour: route;
begin
SetUpToVisit( KnownGalaxy );
FindRandomRoute( GalacticTour, KnownGalaxy );
PrintTour( GalacticTour );
end; {VisitEverySector}
procedure decPath( var home : sectorindex; sec : sector;
var count : integer;
var map : ScannerMap );
{ subtract one for each open sector encountered }
begin
if home <> sec then
decPath( home, distances[ sec ].s, count, map );
if map[sec] = open then
dec( count );
end;
procedure FindScanResults( var EtherProbeInfo : distanceArray;
map : scannermap );
{ Load EtherProbeInfo with EtherProbeInfo.d = # open sectors on path from
base point to EtherProbeInfo.s }
var
BaseSector : sectorIndex;
i : sector;
begin
write('Base sector for etherprobes? (0 to abort) ');
readln( BaseSector );
if BaseSector = 0 then
EtherProbeInfo[1].d := -maxint { code abort }
else
begin
TwoWayDistances( BaseSector, distances, false, true );
for i := 1 to MaxSector do
begin
EtherProbeInfo[i].d := 0;
if distances[i].d <> maxint then
DecPath( BaseSector, i, EtherProbeInfo[i].d, map );
{ We are going to call sort, so these are set to negatives }
EtherProbeInfo[i].s := i;
end; {for}
end; {else}
end;
procedure DisplayEtherResults( ER : distanceArray );
var
i : 1..25;
begin
writeln('Top 25:');
for i := 1 to 25 do
begin
write('Target: ', ER[i].s : 4, ' New count : ', -ER[i].d: 4, ' ':5 );
if not odd(i) then writeln;
end;
writeln;
end;
procedure SuggestEtherProbes;
{Also passed "space" by side effect. Will suggest a list of targets that
will help scan the universe. }
var
KnownGalaxy : scannerMap;
NewScanned : distancearray;
begin
SetUpToVisit( KnownGalaxy );
FindScanResults( NewScanned, KnownGalaxy );
if NewScanned[1].d <> -maxint then {abort at previous step?}
begin
writeln('Sorting...');
SortDistances( NewScanned, MaxSector );
DisplayEtherResults( NewScanned );
end; {if}
end; {SuggestEtherProbes}